home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Src / gc.c < prev    next >
Encoding:
C/C++ Source or Header  |  1996-06-11  |  15.7 KB  |  609 lines
  1. /*
  2.  *
  3.  *  g c . c            -- Mark and Sweep Garbage Collector 
  4.  *
  5.  *
  6.  * Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  7.  * 
  8.  *
  9.  * Permission to use, copy, and/or distribute this software and its
  10.  * documentation for any purpose and without fee is hereby granted, provided
  11.  * that both the above copyright notice and this permission notice appear in
  12.  * all copies and derived works.  Fees for distribution or use of this
  13.  * software or derived works may only be charged with express written
  14.  * permission of the copyright holder.  
  15.  * This software is provided ``as is'' without express or implied warranty.
  16.  *
  17.  * This software is a derivative work of other copyrighted softwares; the
  18.  * copyright notices of these softwares are placed in the file COPYRIGHTS
  19.  *
  20.  *
  21.  *            Author: Erick Gallesio [eg@unice.fr]
  22.  *    Creation date: 17-Feb-1993 12:27
  23.  * Last file update: 11-Jun-1996 21:54
  24.  *
  25.  */
  26.  
  27. #include "stk.h"
  28. #include "gc.h"
  29. #ifdef USE_STKLOS
  30. #  include "stklos.h"
  31. #endif
  32. #ifdef USE_TK
  33. #  include "tk-glue.h"
  34. #endif
  35.  
  36.  
  37. #define MIN_HEAP    100    /* A too small value cause an infinite loop */
  38. #define VALID_ADDRESS(heap_org, p)                        \
  39.     ((p >= heap_org) && (p < heap_org + heap_size) &&            \
  40.      (((((char *)p) - ((char *)heap_org)) % sizeof(struct obj)) == 0))
  41.  
  42. #define HEAPS_INCREMENT 10
  43.  
  44. #define gc_mark(ptr)    STk_gc_mark(ptr)
  45.  
  46. struct gc_protected {
  47.   SCM *location;
  48.   struct gc_protected *next;
  49. };
  50.  
  51.  
  52. /* exported vars */
  53. SCM     STk_freelist;
  54. SCM     *STk_stack_start_ptr;
  55. double  STk_total_gc_time = 0.0;
  56. long    STk_alloc_cells;
  57. int    STk_gc_requested = 0;
  58.  
  59. /* internal vars */
  60. static jmp_buf    save_regs_gc_mark;
  61. static long    gc_cells_collected;
  62. static long    heap_size      = INITIAL_HEAP_SIZE;
  63. static int    gc_verbose     = 0;
  64. static int    gc_calls       = 0;
  65. static SCM     *heaps            = NULL;
  66. static int     heaps_length   = 0;
  67. static int    heaps_used     = 0;
  68. static double   time_gc_start;
  69.  
  70. static struct gc_protected  *protected_registers = NULL;
  71.  
  72. static no_memory(void)
  73. {
  74.   STk_panic("**** No more memory. Cannot allocate a new heap. Stop\n");
  75. }
  76.  
  77. static void allocate_new_heap(void)
  78. {
  79.   SCM ptr, next;
  80.   SCM heap_org, heap_end;
  81.  
  82.   /* Don't use must_malloc here since it can conduct to call GC when 
  83.    * allocating large heaps (typically with large -cells xxx)
  84.    */
  85.  
  86.   if (heaps_used == heaps_length) {
  87.     /* Realloc heaps */
  88.     heaps_length += HEAPS_INCREMENT;
  89.     heaps         = (heaps_used) ?  realloc(heaps, heaps_length*sizeof(SCM)):
  90.                     malloc(heaps_length*sizeof(SCM));
  91.     if (!heaps) no_memory();
  92.   }
  93.   ptr = (SCM) malloc(sizeof(struct obj)*heap_size);
  94.   if (ptr) {
  95.     heap_org =  heaps[heaps_used++] = ptr;
  96.     heap_end = heap_org + heap_size;
  97.   }
  98.   else 
  99.     no_memory();
  100.  
  101.   /* Prepare heap space */
  102.   for(ptr = heap_org, next=ptr+1; ptr < heap_end; ptr=next, next=ptr+1) {
  103.     ptr->type      = tc_free_cell;
  104.     ptr->cell_info = 0;
  105.     ptr->gc_mark   = 0;
  106.     CDR(ptr) = (next < heap_end) ? next : STk_freelist;
  107.   }
  108.   STk_freelist = heap_org;
  109.  
  110.   if (gc_verbose)
  111.     fprintf(STk_stderr, ";; [new heap allocated (%d/%d)]\n", 
  112.                 heaps_used, heaps_length);
  113. }
  114.  
  115. static void gc_start(void)
  116. {
  117.   time_gc_start       = STk_my_time();
  118.   gc_calls           += 1;
  119.   gc_cells_collected  = 0;
  120.   gc_verbose          = (VCELL(Intern(GC_VERBOSE)) != Ntruth);
  121.  
  122.   if (gc_verbose) fprintf(STk_stderr, ";; [starting GC]\n");
  123. }
  124.  
  125. static void gc_end(void)
  126. {
  127.   long total_cells, used_cells;
  128.   double time_for_this_gc;
  129.  
  130.   total_cells = heaps_used * heap_size;
  131.   used_cells  = total_cells - gc_cells_collected;
  132.  
  133.   time_for_this_gc   = STk_my_time() - time_gc_start;
  134.   STk_total_gc_time += time_for_this_gc;
  135.  
  136.   /* 
  137.    * If heap is more than 75% filled after gc, allocate a new heap to 
  138.    * avoid continuous GCs
  139.    */
  140.   if (((float) used_cells / total_cells) > 0.75) allocate_new_heap();
  141.  
  142.   STk_gc_requested = 0;
  143.  
  144.   if (gc_verbose) 
  145.     fprintf(STk_stderr, ";; [end of GC (cells used: %ld/%ld; time: %.2fms)]\n", 
  146.                     used_cells, total_cells, time_for_this_gc);
  147.   STk_handle_signal(SIGHADGC);
  148. }
  149.  
  150.  
  151. void STk_gc_count_cells(long *allocated, long *used, long* calls)
  152. {
  153.   register SCM ptr, heap_org, heap_end;
  154.   register long used_cells = 0L;
  155.   int i;
  156.  
  157.   for (i=0; i < heaps_used; i++) {
  158.     heap_org = heaps[i];
  159.     heap_end = heap_org + heap_size;
  160.  
  161.     for(ptr = heap_org; ptr < heap_end; ptr++) 
  162.       if (NTYPEP(ptr, tc_free_cell)) used_cells    += 1;
  163.   }
  164.  
  165.   *allocated = heaps_used * heap_size;
  166.   *used      = used_cells;
  167.   *calls     = (long) gc_calls;
  168. }
  169.  
  170.  
  171.  
  172.  
  173. int STk_valid_address(SCM p)    /* True if p is a valid address. Used for #Pxyz */
  174. {
  175.   int i;
  176.   
  177.   for(i=0; i < heaps_used; i++) {
  178.     register SCM heap_org=heaps[i];
  179.     
  180.     if (VALID_ADDRESS(heap_org, p)) return TRUE;
  181.   }
  182.  
  183.   return FALSE;
  184. }
  185.  
  186.  
  187. void STk_gc_mark(SCM ptr)
  188. {
  189. Top:
  190.    if (NULLP(ptr) || SMALL_CSTP(ptr)) return;
  191.    if (ptr->gc_mark)              return;
  192.  
  193.    ptr->gc_mark = GC_MARK;
  194.  
  195.    switch (TYPE(ptr)) {
  196.      case tc_nil:       return;
  197.      case tc_cons:      gc_mark(CAR(ptr));ptr = CDR(ptr); goto Top;
  198.      case tc_flonum:      return;
  199.      case tc_integer:      return;
  200.      case tc_bignum:      return;
  201.      case tc_symbol:      ptr = VCELL(ptr);goto Top;
  202.      case tc_keyword:      return;  
  203.      case tc_subr_0:      return;
  204.      case tc_subr_1:      return;
  205.      case tc_subr_2:      return;
  206.      case tc_subr_3:      return;
  207.      case tc_subr_0_or_1: return;
  208.      case tc_subr_1_or_2: return;
  209.      case tc_subr_2_or_3: return;
  210.      case tc_lsubr:      return;
  211.      case tc_ssubr:      return;
  212.      case tc_fsubr:      return;
  213.      case tc_syntax:      return;
  214.      case tc_closure:      gc_mark(ptr->storage_as.closure.code);
  215.               ptr = ptr->storage_as.closure.env;
  216.               goto Top;
  217.      case tc_free_cell:      /* -----> Error */
  218.      case tc_char:      return;
  219.      case tc_string:      return;
  220.      case tc_vector:      {
  221.                        long j;
  222.                 for(j = 0;j < ptr->storage_as.vector.dim; j++)
  223.                   gc_mark(ptr->storage_as.vector.data[j]);
  224.                 return;
  225.               }
  226.      case tc_eof:            return;
  227.      case tc_undefined:      return;
  228.      case tc_iport:      
  229.      case tc_oport:      gc_mark(PORT_REVENT(ptr)); 
  230.               ptr = PORT_WEVENT(ptr);       
  231.               goto Top;
  232.      case tc_isport:      return;
  233.      case tc_osport:      return;
  234.      case tc_boolean:      return;
  235.      case tc_macro:      ptr = ptr->storage_as.macro.code; goto Top;
  236.      case tc_localvar:      ptr = ptr->storage_as.localvar.symbol; goto Top;
  237.      case tc_globalvar:      ptr = VCELL(ptr); goto Top;
  238.      case tc_cont:      ptr = STk_mark_continuation(ptr);
  239.                      goto Top;
  240.      case tc_env:
  241.      case tc_address:      ptr = ptr->storage_as.env.data;
  242.               goto Top;
  243.      case tc_autoload:      ptr = CAR(ptr);
  244.                      goto Top;
  245.      case tc_Cpointer:    return;
  246. #ifdef USE_STKLOS
  247.      case tc_instance:       {
  248.                        /* ACCESSORS_OF(ptr) doesn't need to be marked since it 
  249.                  * is always accessible from SLOTS_OF(CLASS_OF(ptr))
  250.                  */
  251.                        long j;
  252.  
  253.                 gc_mark(CLASS_OF(ptr));
  254.                 for (j = 0; j < NUMBER_OF_SLOTS(ptr); j++)
  255.                   gc_mark(THE_SLOT_OF(ptr, j));
  256.                 return;
  257.               }
  258.      case tc_next_method: gc_mark(CAR(ptr)); ptr = CDR(ptr); goto Top;
  259. #endif
  260. #ifdef USE_TK
  261.      case tc_tkcommand:      ptr = ptr->storage_as.tk.l_data; goto Top;
  262. #endif
  263.      case tc_quote:      return;
  264.      case tc_lambda:      return;
  265.      case tc_if:      return;
  266.      case tc_setq:      return;
  267.      case tc_cond:      return;
  268.      case tc_and:      return;
  269.      case tc_or:      return;
  270.      case tc_let:      return;
  271.      case tc_letstar:      return;
  272.      case tc_letrec:      return;
  273.      case tc_begin:      return;
  274.      case tc_promise:       ptr = ptr->storage_as.promise.expr; goto Top;
  275.      case tc_apply:
  276.      case tc_call_cc:      return;
  277.      case tc_dynwind:      return;
  278.      case tc_extend_env:  return;
  279.      case tc_unbound:     return;
  280.      default:          if (EXTENDEDP(ptr)) {STk_extended_mark(ptr); return;}
  281.    }
  282.    /* if we are here, it's an implementation error. Signal it */
  283.    fprintf(STk_stderr, "INTERNAL ERROR: trying to mark %lx (type=%d)\n", 
  284.                    (unsigned long) ptr, TYPE(ptr));
  285. }
  286.  
  287. static void gc_sweep(void)
  288. {
  289.   SCM ptr, heap_org, heap_end, nfreelist;
  290.   long n;
  291.   int  i;
  292.  
  293.   n         =  0;
  294.   nfreelist = NIL;
  295.  
  296.   for (i = 0; i < heaps_used; i++) {
  297.     /* Sweep a heap */
  298.     heap_org = heaps[i];
  299.     heap_end = heap_org + heap_size;
  300.  
  301.     for (ptr=heap_org; ptr < heap_end; ptr++) {
  302.       if (ptr->gc_mark == 0) {
  303.     switch (TYPE(ptr)) {
  304.           case tc_nil:            break;
  305.       case tc_cons:           break;
  306.       case tc_flonum:      free(ptr->storage_as.flonum.data);
  307.       case tc_integer:     break;
  308.       case tc_bignum:      mpz_clear(BIGNUM(ptr)); free(BIGNUM(ptr)); break;
  309.       case tc_symbol:      STk_free_symbol(ptr); break;
  310.       case tc_keyword:     STk_free_keyword(ptr); break;
  311.       case tc_subr_0:      break;
  312.       case tc_subr_1:      break;
  313.       case tc_subr_2:      break;
  314.       case tc_subr_3:      break;
  315.       case tc_subr_0_or_1: break;
  316.       case tc_subr_1_or_2: break;
  317.       case tc_subr_2_or_3: break;
  318.       case tc_lsubr:       break;
  319.       case tc_ssubr:       break;
  320.       case tc_fsubr:       break;
  321.       case tc_syntax:      break;
  322.       case tc_closure:     break;
  323.       case tc_free_cell:   break;
  324.       case tc_char:           break;
  325.       case tc_string:      free(ptr->storage_as.string.data); break;
  326.       case tc_vector:      free(ptr->storage_as.vector.data); break;
  327.       case tc_eof:         break;
  328.       case tc_undefined:   break;
  329.       case tc_iport:       
  330.       case tc_oport:       STk_freeport(ptr); break;
  331.       case tc_isport:      
  332.       case tc_osport:      STk_free_string_port(ptr); break;
  333.       case tc_boolean:     break;
  334.       case tc_macro:       break;
  335.       case tc_localvar:    break;
  336.       case tc_globalvar:   break;
  337.       case tc_cont:           free(ptr->storage_as.cont.data); break;
  338.       case tc_env:           break;
  339.       case tc_address:     break;
  340.       case tc_autoload:    break;
  341.       case tc_Cpointer:    if (!EXTSTATICP(ptr)) free(EXTDATA(ptr)); break;
  342. #ifdef USE_STKLOS
  343.       case tc_instance:    free(INST(ptr));     break;
  344.       case tc_next_method: break;
  345. #endif
  346. #ifdef USE_TK
  347.       case tc_tkcommand:   if (ptr->storage_as.tk.data->Id[0])
  348.                 /* This object was renamed (rather than deleted) */
  349.                       Tcl_DeleteCommand(STk_main_interp,
  350.                             ptr->storage_as.tk.data->Id);
  351.                    free(ptr->storage_as.tk.data); 
  352.                    break;
  353. #endif
  354.       case tc_quote:       break;
  355.       case tc_lambda:      break;
  356.       case tc_if:           break;
  357.       case tc_setq:           break;
  358.       case tc_cond:           break;
  359.       case tc_and:           break;
  360.       case tc_or:           break;
  361.       case tc_let:           break;
  362.       case tc_letstar:     break;
  363.       case tc_letrec:      break;
  364.       case tc_begin:       break;
  365.       case tc_promise:     break;
  366.       case tc_apply:       break;
  367.       case tc_call_cc:     break;
  368.       case tc_dynwind:     break;
  369.       case tc_extend_env:  break;
  370.       case tc_unbound:     break;
  371.       default:           if (EXTENDEDP(ptr))
  372.                     STk_extended_sweep(ptr);
  373.                      else
  374.                  fprintf(STk_stderr,
  375.                      "FATAL ERROR: trying to sweep %lx "
  376.                      "(type=%d)\n",
  377.                      (unsigned long) ptr, TYPE(ptr));
  378.         }
  379.     
  380.     /* Declare this cell free and put it in free list */
  381.     ptr->type    = tc_free_cell;
  382.     ptr->cell_info  = 0;
  383.     CDR(ptr)    = nfreelist;
  384.     nfreelist    = ptr;
  385.     n              += 1;
  386.       }
  387.       else 
  388.     ptr->gc_mark = 0;
  389.     }
  390.   }
  391.   gc_cells_collected = n;
  392.   STk_freelist          = nfreelist;
  393. }
  394.  
  395. void STk_mark_stack(SCM *start, SCM *end)
  396. {
  397.   register SCM p, heap_org;
  398.   register long i, j, n;
  399.   
  400.   if (start > end) {
  401.     SCM *tmp;
  402.     tmp = start; start = end; end = tmp;
  403.   }
  404.   n = end - start;
  405.  
  406.   if (gc_verbose)
  407.     fprintf(STk_stderr, "[Marking zone <0x%lx->0x%lx> (%ld words)]\n",
  408.         (unsigned long) start, (unsigned long) end, (unsigned long) n);
  409.   for(j=0; j<n; j++) {
  410.     p = start[j];
  411.     /* if p looks as a SCM pointer mark location */
  412.     for (i=0; i < heaps_used; i++) {
  413.       heap_org = heaps[i];
  414.       if (VALID_ADDRESS(heap_org, p) && NTYPEP(p,tc_free_cell)) gc_mark(p);
  415.     }
  416.   }
  417. }
  418.  
  419. static void mark_protected(void)
  420. {
  421.   struct gc_protected *reg;
  422.  
  423.   /* Mark protected vars */
  424.   for(reg = protected_registers; reg; reg = reg->next) gc_mark(*(reg->location));
  425.   
  426.   /* Mark all objects accessible from obarray */
  427.   STk_mark_symbol_table();
  428.  
  429.   /* Mark the signal table */
  430.   STk_mark_signal_table();
  431.  
  432.   /* Mark the table of traced variables */
  433.   STk_mark_tracevar_table();
  434.  
  435. #ifdef USE_TK
  436.   /* Mark all Tcl/Tk callbacks */
  437.   STk_mark_callbacks();
  438. #endif
  439. }
  440.  
  441.  
  442. static void gc_mark_and_sweep(void)
  443. {
  444.   SCM stack_end;    /* The topmost variable allocated on stack */
  445.  
  446.   gc_start();
  447.   setjmp(save_regs_gc_mark);
  448.   STk_mark_stack((SCM *) save_regs_gc_mark,
  449.          (SCM *) (((char *) save_regs_gc_mark)+sizeof(save_regs_gc_mark)));
  450.   mark_protected();
  451.   STk_mark_stack((SCM *) STk_stack_start_ptr, (SCM *) &stack_end);
  452.  
  453.   gc_sweep();
  454.   gc_end();
  455. }
  456.  
  457. void STk_gc_for_newcell(void)
  458. {
  459.   if (Error_context != ERR_FATAL) {
  460.     STk_disallow_sigint();
  461.     Error_context = ERR_FATAL;
  462.     gc_mark_and_sweep();
  463.     Error_context = ERR_OK;
  464.     STk_allow_sigint();
  465.     if (NNULLP(STk_freelist)) return;
  466.   }
  467.   Err("Out of storage",NIL);
  468. }
  469.  
  470.  
  471. PRIMITIVE STk_gc(void)
  472. {
  473.   STk_disallow_sigint();
  474.   Error_context = ERR_FATAL;
  475.   gc_mark_and_sweep();
  476.   Error_context = ERR_OK;
  477.   STk_allow_sigint();
  478.  
  479.   return UNDEFINED;
  480. }
  481.  
  482. void STk_gc_protect(SCM *location)
  483. {
  484.   struct gc_protected *reg;
  485.  
  486.   reg = (struct gc_protected *) must_malloc(sizeof(struct gc_protected));
  487.   
  488.   reg->location     = location;
  489.   reg->next         = protected_registers;
  490.   protected_registers     = reg;
  491. }
  492.  
  493. void STk_gc_unprotect(SCM *location)
  494. {
  495.   struct gc_protected *reg, *prev;
  496.  
  497.   for (prev=NULL, reg=protected_registers; reg; prev=reg, reg=reg->next) 
  498.     if (reg->location == location) {
  499.       if (prev) 
  500.     prev->next = reg->next;
  501.       else
  502.     protected_registers = reg->next;
  503.       free(reg);
  504.       return;
  505.     }
  506. }
  507.  
  508.  
  509. PRIMITIVE STk_gc_stats(void)
  510. {
  511.   int i, freq[tc_stop_extd+1];
  512.   register SCM ptr, heap_org, heap_end;
  513.   long used_cells = 0L;
  514.  
  515.   /* Reset array of frequencies */
  516.   for (i=0; i <=tc_stop_extd; i++) freq[i] =  0;
  517.   
  518.   /* Fill the frequencies array */
  519.   for (i=0; i < heaps_used; i++) {
  520.     heap_org = heaps[i];
  521.     heap_end = heap_org + heap_size;
  522.  
  523.     for(ptr = heap_org; ptr < heap_end; ptr++) {
  524.       if (NTYPEP(ptr, tc_free_cell)) {
  525.     used_cells     += 1;
  526.     freq[TYPE(ptr)] += 1;
  527.       }
  528.     }
  529.   }
  530.  
  531.   /* Print statistics */
  532.   fprintf(STk_stderr, ";; GC statistics\n");
  533.   fprintf(STk_stderr, ";; -------------\n");
  534.   fprintf(STk_stderr, ";; cells used %ld/%ld\n", used_cells, heaps_used*heap_size);
  535.   fprintf(STk_stderr, ";; # of used heaps %d\n", heaps_used);
  536.   fprintf(STk_stderr, ";; # of GC calls %d (time spent in GC %.2fms)\n", 
  537.                 gc_calls, STk_total_gc_time);
  538.  
  539.   for (i=0; i <= tc_stop_extd; i++)
  540.     if (freq[i]) fprintf(STk_stderr, "(%d %d) ", i,  freq[i]);
  541.   fprintf(STk_stderr, "\n;;\n");
  542.  
  543.   return UNDEFINED;
  544. }
  545.  
  546.  
  547. PRIMITIVE STk_find_cells(SCM type)
  548. {
  549.   SCM ptr, z, heap_org, heap_end;
  550.   int i,t,l;
  551.  
  552.   if (NINTEGERP(type)) Err("%find-cells: bad integer", type);
  553.   t = INTEGER(type);
  554.  
  555.   /* Count how many items we have */
  556.   for (i=l=0; i < heaps_used; i++) {
  557.     heap_org = heaps[i];
  558.     heap_end = heap_org + heap_size;
  559.     
  560.     for (ptr=heap_org; ptr < heap_end; ptr++)
  561.       if (TYPEP(ptr, t)) l += 1;
  562.   }
  563.  
  564.   /* Allocate a vector for the result */
  565.   z = STk_makevect(l, NULL);
  566.   l = 0;
  567.   
  568.   /* Place all the items in the newly created vector */
  569.   for (i=l=0; i < heaps_used; i++) {
  570.     heap_org = heaps[i];
  571.     heap_end = heap_org + heap_size;
  572.   
  573.     for (ptr=heap_org; ptr < heap_end; ptr++)
  574.       if (ptr != z && TYPEP(ptr, t))
  575.     VECT(z)[l++] = ptr;
  576.   }
  577.   return z;
  578. }
  579.  
  580. PRIMITIVE STk_expand_heap(SCM arg)
  581. {
  582.   int i, number_of_heaps, wanted;
  583.  
  584.   if (NINTEGERP(arg)) Err("expand-heap: bad integer", arg);
  585.  
  586.   gc_verbose      = VCELL(Intern(GC_VERBOSE))!=Ntruth;
  587.   wanted      = INTEGER(arg);
  588.   number_of_heaps = (wanted + heap_size - 1) / heap_size;
  589.   
  590.   for (i = heaps_used; i < number_of_heaps; i++)
  591.     allocate_new_heap();
  592.   return UNDEFINED;
  593. }
  594.  
  595. #ifndef max
  596. #define max(a,b) (((a)<(b))?(b):(a))
  597. #endif 
  598.  
  599. void STk_init_gc(void)
  600. {
  601.   STk_freelist = NIL;
  602.   if (STk_arg_cells) {
  603.     /* Set the heap size to the specified value */
  604.     int tmp = atoi(STk_arg_cells);
  605.     if (tmp > 0) heap_size = max(tmp,MIN_HEAP);
  606.   }
  607.   allocate_new_heap();
  608. }
  609.